perm filename ADVISE[LSP,JRA] blob
sn#189835 filedate 1975-12-03 generic text, type T, neo UTF8
(FILECREATED " 2-MAR-75 14:27:31" <NEWLISP>ADVISE.;1 11159
changes to: ADVISE UNADVISE READVISE0 READVISE1
previous date: "30-OCT-74 19:24:03" <LISP>ADVISE.;4)
(LISPXPRINT (QUOTE ADVISECOMS)
T T)
[RPAQQ ADVISECOMS ((FNS * ADVISEFNS)
(VARS (ADVISEDFNS)
(ADVINFOLST))
(P (MAP2C (QUOTE (PROG SETQ RETURN))
(QUOTE (ADV-PROG ADV-SETQ ADV-RETURN))
(FUNCTION MOVD)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA READVISE
UNADVISE)
(NLAML]
(RPAQQ ADVISEFNS (ADVISE ADVISE1 UNADVISE ADVISEDUMP READVISE READVISE0 READVISE1 ADDRULE
CADVICE))
(DEFINEQ
ε∧(ADVISEε↓
[LAMBDA (FN WHEN WHERE WHAT)
(PROG (X Y D)
TOP [COND
((ATOM FN)
(SETQ FN (FNCHECK FN)))
[(EQ (CADR FN)
(QUOTE IN))
(SETQ Y (CADDR FN))
(RETURN (COND
[(ATOM (SETQ X (CAR FN)))
(COND
((ATOM Y)
(εαADVISE1ε↓ X Y))
(T (MAPCAR Y (FUNCTION (LAMBDA (Y)
(εαADVISE1ε↓ X Y T]
[(ATOM Y)
(MAPCAR X (FUNCTION (LAMBDA (X)
(εαADVISE1ε↓ X Y T]
(T (MAPCONC X (FUNCTION (LAMBDA (X)
(MAPCAR Y (FUNCTION (LAMBDA (Y)
(εαADVISE1ε↓ X Y T]
(T (RETURN (MAPCAR FN (FUNCTION (LAMBDA (X)
(εαADVISEε↓ X (COPY WHEN)
(COPY WHERE)
(COPY WHAT]
(COND
((OR WHAT (NULL WHEN))
εβ(* E.g. ADVISE (FOO), the simplest form, means just set up function for ε↓
εβadvising and exit, or ADVISE (FOO BEFORE/AFTER where ADVICE) the full form.)ε↓
NIL)
((NULL WHERE)
εβ(* E.g. ADVISE (FOO advice) equivalent to ADVISE ε↓
εβ(FOO BEFORE NIL advice))ε↓
(SETQ WHAT WHEN)
(SETQ WHEN (QUOTE BEFORE)))
(T
εβ(* E.g. ADVISE (FOO AFTER advice) equivalent to ADVISE ε↓
εβ(FOO AFTER NIL advice))ε↓
(SETQ WHAT WHERE)
(SETQ WHERE NIL)))
(RESTORE FN (QUOTE BROKEN))
[COND
[(NULL (SETQ D (GETD FN)))
(HELP (CONS FN (QUOTE (NOT DEFINED]
([OR (NULL (EXPRP D))
(NULL (GETP FN (QUOTE ADVISED]
(SETQ Y (SAVED FN (QUOTE ADVISED)
D))
[/PUTD FN (LIST (CAR Y)
(CADR Y)
(SETQ Y (SUBPAIR (QUOTE (DEF))
[LIST (COND
((CDR (SETQ Y (CDDR Y)))
(CONS (QUOTE PROGN)
Y))
(T (CAR Y]
(COPY (QUOTE (ADV-PROG
(!VALUE)
(ADV-SETQ !VALUE
(ADV-PROG NIL
(ADV-RETURN
DEF)))
(ADV-RETURN !VALUE]
εβ(* The SUBPAIR is so that DEF is notε↓
εβcopied.)ε↓
)
(T (SETQ Y (CADDR D]
(/SETTOPVAL (QUOTE ADVISEDFNS)
|
(CONS FN (/DREMOVE FN ADVISEDFNS)))
|
εβ(* So FN is moved to the front of ADVISEDFNS if it is already there.)ε↓
(SETQ X WHEN)
LP (SELECTQ X
(NIL εβ(* E.g. ADVISE (FOO) means set up ε↓
εβadvising and return.)ε↓
(RETURN FN))
[BEFORE (SETQ Y (CDDR (CADDR (CADDR Y]
(AFTER (SETQ Y (CDDDR Y)))
(AROUND [SETQ Y (CAR (LAST (CADDR (CADDR Y]
(COND
((NEQ (CAR Y)
(QUOTE ADV-RETURN))
(GO ERROR)))
(/RPLACA (CDR Y)
(SUBST (CADR Y)
(QUOTE *)
WHAT))
(GO EXIT))
(BIND [/NCONC (CADR Y)
(COND
((ATOM WHAT)
(LIST WHAT))
(T (APPEND WHAT]
(GO EXIT))
(GO ERROR))
(COND
((NULL WHERE) εβ(* Most common case.)ε↓
(/ATTACH WHAT (FLAST Y)))
(T (εαADDRULEε↓ Y WHAT WHERE T)))
EXIT(/ADDPROP FN (QUOTE ADVICE)
(LIST WHEN WHERE WHAT))
(RETURN FN)
ERROR
(ERROR (LIST (QUOTE ADVISE) WHEN (QUOTE ?])
ε∧(ADVISE1ε↓
[LAMBDA (X Y FLG)
(PROG (Z)
(COND
([NOT (ATOM (SETQ Z (CHNGNM Y (FNCHECK X NIL T]
εβ(* CHNGNM checks to see if name already changed, so that user can always ε↓
εβADVISE with either atomic or list form for aliases.)ε↓
(RETURN Z))
(FLG εβ(* Will be done more than once.)ε↓
(εαADVISEε↓ Z (COPY WHEN)
(COPY WHERE)
(COPY WHAT)))
(T (εαADVISEε↓ Z WHEN WHERE WHAT)))
(RETURN Z])
ε∧(UNADVISEε↓
[NLAMBDA X
(COND
[(EQ (CAR X)
T) εβ(* Just UNADVISE last function.)ε↓
(SETQ X (LIST (CAR ADVISEDFNS]
((NULL X)
(SETQ X (REVERSE ADVISEDFNS))
(/SETTOPVAL (QUOTE ADVISEDFNS)
|
NIL)
|
(/SETTOPVAL (QUOTE ADVINFOLST)
|
NIL)))
|
(MAPCONC X (FUNCTION (LAMBDA (FN)
(MAPCAR (PACK-IN- FN)
(FUNCTION (LAMBDA (FN)
(PROG [(ADVICE (GETP FN (QUOTE ADVICE)))
(ALIAS (GETP FN (QUOTE ALIAS)))
(READVICE (GETP FN (QUOTE READVICE]
[COND
((AND DWIMFLG (NULL (FMEMB FN ADVISEDFNS))
(NULL (FNTYP FN)))
(SETQ FN (OR (FIXSPELL FN 70 ADVISEDFNS)
(FIXSPELL FN 70 USERWORDS NIL NIL
(FUNCTION FNTYP))
FN]
(/REMPROP FN (QUOTE BROKEN))
(/SETTOPVAL (QUOTE BROKENFNS)
|
(/DREMOVE FN BROKENFNS))
|
(/SETTOPVAL (QUOTE ADVISEDFNS)
|
(/DREMOVE FN ADVISEDFNS))
|
(COND
(ALIAS (CHNGNM (CAR ALIAS)
(CDR ALIAS)
T)))
[COND
((AND ADVICE READVICE)
εβ(* The advice for FN is to be permanently saved, as indicated by the ε↓
εβpresence of the property 'READVICE'. The advice on 'ADVICE' dominates that ε↓
εβon 'READVICE' since the user may have added new pieces of advice.)ε↓
(/PUT FN (QUOTE READVICE)
(CONS ALIAS ADVICE]
(/SETTOPVAL (QUOTE ADVINFOLST)
|
(CONS (CONS FN (CONS ALIAS ADVICE))
|
ADVINFOLST))
|
εβ(* Adds to front so READVISE ε↓
εβ(T) will get last function ε↓
εβunadvised.)ε↓
(/REMPROP FN (QUOTE ADVICE))
(RETURN (RESTORE FN (QUOTE ADVISED])
ε∧(ADVISEDUMPε↓
[LAMBDA (X FLG) εβ(* FLG is T for 'ADVISE' and NIL forε↓
εβ'ADVICE')ε↓
[SETQ X (MAPCONC X (FUNCTION (LAMBDA (FN)
(MAPCAR (PACK-IN- FN)
(FUNCTION (LAMBDA (FN)
(PROG (Y)
[COND
((SETQ Y (GETP FN (QUOTE ADVICE)))
(PUT FN (QUOTE READVICE)
(CONS (GETP FN (QUOTE ALIAS))
(APPEND Y]
(RETURN FN]
(MAKEDEFLIST X (QUOTE READVICE))
(COND
(FLG (PRINTDEF1 (CONS (QUOTE READVISE)
X])
ε∧(READVISEε↓
[NLAMBDA X
εβ(* ADVISE, UNADVISE, and READVISE work similarly to BREAK, UNBREAK, and ε↓
εβREBREAK, except that once readvised, a function's advice is permanently ε↓
εβsaved on its property list under the property 'READVICE'.ε↓
εβSubsequent calls to UNADVISE update the property 'READVICE' so that the ε↓
εβsequence READVISE, ADVISE, UNADVISE, causes the augmented advice to become ε↓
εβpermanent. note that the sequence READVISE, ADVISE, READVISE, removes the ε↓
εβintermediate advice by restoring the function to its earlier state.)ε↓
(PROG (SPLST)
(RETURN (COND
((NULL X)
(MAPCAR (REVERSE ADVINFOLST)
(FUNCTION READVISE1)))
((EQ (CAR X)
T)
(εαREADVISE1ε↓ (CAR ADVINFOLST)))
(T (SETQ SPLST (INTERSECTION [SETQ SPLST
(APPEND ADVISEDFNS
(MAPCAR ADVINFOLST
(FUNCTION CAR]
SPLST))
(MAPCONC X (FUNCTION (LAMBDA (FN)
(MAPCAR (PACK-IN- FN)
(FUNCTION READVISE0])
ε∧(READVISE0ε↓
[LAMBDA (FN)
(PROG (Y)
LP [SETQ Y (OR (GETP FN (QUOTE READVICE))
(COND
((SETQ Y (GETP FN (QUOTE ADVICE)))
(CONS (GETP FN (QUOTE ALIAS))
Y)))
(CDR (FASSOC FN ADVINFOLST]
(RETURN (COND
(Y (εαREADVISE1ε↓ Y FN))
([AND DWIMFLG (NULL (FNTYP FN))
(SETQ Y (OR (FIXSPELL FN 70 SPLST)
(FIXSPELL FN 70 USERWORDS NIL NIL (FUNCTION FNTYP]
(SETQ FN Y)
(GO LP))
(T (CONS FN (QUOTE (- no advice saved])
ε∧(READVISE1ε↓
[LAMBDA (LST FN)
(PROG (ALIAS)
[COND
((NULL FN)
(SETQ FN (CAR LST))
(SETQ LST (CDR LST]
(/PUT FN (QUOTE READVICE)
LST)
[COND
((SETQ ALIAS (CAR LST))
(CHNGNM (CAR ALIAS)
(CDR ALIAS]
(/REMPROP FN (QUOTE ADVICE))
(RESTORE FN (QUOTE BROKEN))
(RESTORE FN (QUOTE ADVISED))
(/SETTOPVAL (QUOTE ADVISEDFNS)
|
(/DREMOVE FN ADVISEDFNS))
|
(SETQ LST (CDR LST))
LP (APPLY (QUOTE ADVISE)
(CONS FN (CAR LST)))
εβ(* Want to do it at least once, even if CDR LST is NIL.)ε↓
(COND
((SETQ LST (CDR LST))
(GO LP)))
(RETURN FN])
ε∧(ADDRULEε↓
[LAMBDA (LST NEW WHERE FLG)
(PROG (X Y)
LP (COND
[(ATOM WHERE)
(RETURN (SELECTQ WHERE [(LAST BOTTOM END NIL)
(COND
(FLG (/ATTACH NEW (FLAST LST))
LST)
(T (/NCONC LST (LIST NEW]
((FIRST TOP)
(/ATTACH NEW LST))
(GO BAD]
((NULL (CDR WHERE))
(SETQ WHERE (CAR WHERE))
(GO LP)))
(COND
((NULL FLG))
((SETQ X (NLEFT LST 2))
εβ(* There is an extra expression at the end of RULES.ε↓
εβIt is temporarily removed before calling editor to avoid conflict.)ε↓
(SETQ FLG (CDR X))
(/RPLACD X NIL))
(T (GO BAD)))
(AND (PROG1 [NLSETQ (EDITE LST (LIST (CONS (QUOTE LC)
(CDR WHERE))
(QUOTE (BELOW ↑))
(LIST (CAR WHERE)
NEW]
(AND FLG (/NCONC LST FLG)))
(RETURN LST))
BAD (PRINT (CONS WHERE (QUOTE (not found)))
T T)
(ERROR!])
ε∧(CADVICEε↓
[LAMBDA (FNS)
[MAPC FNS (FUNCTION (LAMBDA (X)
(CHANGEPROP X (QUOTE ADVISED)
(QUOTE CADVISED))
(CHANGEPROP X (QUOTE EXPR)
(QUOTE ORIGEXPR]
(COMPILE FNS)
[MAPC FNS (FUNCTION (LAMBDA (X)
(CHANGEPROP X (QUOTE CADVISED)
(QUOTE ADVISED))
(REMPROP X (QUOTE EXPR))
(CHANGEPROP X (QUOTE ORIGEXPR)
(QUOTE EXPR]
FNS])
)
(RPAQ ADVISEDFNS)
(RPAQ ADVINFOLST)
(MAP2C (QUOTE (PROG SETQ RETURN))
(QUOTE (ADV-PROG ADV-SETQ ADV-RETURN))
(FUNCTION MOVD))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA READVISE UNADVISE)
(ADDTOVAR NLAML)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (668 10870 (ADVISE 680 . 3962) (ADVISE1 3966 . 4484) (UNADVISE 4488 . 6523)
(ADVISEDUMP 6527 . 7096) (READVISE 7100 . 8153) (READVISE0 8157 . 8674) (READVISE1 8678 .
9453) (ADDRULE 9457 . 10457) (CADVICE 10461 . 10867)))))
STOP